home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / repl.t < prev    next >
Text File  |  1988-02-05  |  6KB  |  158 lines
  1. (herald repl (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; system initialization and read-eval-print loop
  27.  
  28.  
  29. ;;; (breakpoint [message [env]]) simply punts to t-breakpoint.
  30.  
  31. (define (t-breakpoint . args)
  32.   (cond ((null? args)
  33.          (t-breakpoint-aux nil read-eval-print-loop))
  34.         ((or (null? (cdr args)) (null? (cadr args)))
  35.          (t-breakpoint-aux (car args) read-eval-print-loop))
  36.         (else
  37.          ;++ why not give repl a env arg?
  38.          (bind (((repl-env) (enforce environment? (cadr args))))
  39.            (t-breakpoint-aux (car args) read-eval-print-loop)))))
  40.  
  41. ;;; The most weird (i.e. weirdest) control structure in the system.
  42.  
  43. (lset **up** luser-typed-eof-at-top-level)
  44.  
  45. (define (t-breakpoint-aux message repl)
  46.   (catch ret
  47.     (if message (format (repl-output) "~&~a" message))
  48.     (catch up
  49.       (let ((previous-up **up**))
  50.         (bind ((*break-level* (fx+ *break-level* 1))
  51.                (**up** up)
  52.                (**ret** ret))
  53.           (repl repl-input repl-output)
  54.           (previous-up))))
  55.     ;; a throw to up comes here.
  56.     (t-breakpoint-aux nil repl)))
  57.  
  58. ;;; read-eval-print loop.
  59. ;;; typing end-of-file (^z or ^d) is the only way this can ever return.
  60.  
  61. (define (read-eval-print-loop in out)
  62.   (iterate loop ()
  63.     (fresh-line (out))
  64.     (prompt (out) ((repl-prompt) *break-level*))
  65.     (let ((form ((repl-read) (in))))
  66.       (cond ((eof? form) form)
  67.             (else
  68.              (receive vals
  69.                       ;; evaluate the user's form.
  70.                       ((repl-eval) form (repl-env))
  71.                (cond ((null? vals)
  72.                       (format (out) "~&;no value")
  73.                       (loop))
  74.                      ((not (null? (cdr vals)))
  75.                       (set (repl-results) vals)
  76.                       (format (out) "~&;multiple values:")
  77.                       (do ((l vals (cdr l))
  78.                            (i 0 (fx+ i 1)))
  79.                           ((null? l) (loop))
  80.                         (format (out) "~% [~s] " i)
  81.                         ((repl-print) (car l) (out))))
  82.                      ((not (repl-wont-print? (car vals)))
  83.                       ;; single value
  84.                       (set (repl-results) vals)
  85.                       ((repl-print) (car vals) (out))
  86.                       (loop))
  87.                      (else (loop)))))))))
  88.  
  89. (define repl-results
  90.   (let ((weak (make-weak-cell (list (undefined-value "##")))))
  91.     (object (lambda () (weak-cell-contents weak))
  92.       ((setter self)
  93.        (lambda (val)
  94.          (let ((val (enforce list? val)))
  95.            (set (weak-cell-contents weak) val)
  96.            val))))))
  97.  
  98. (define-simple-switch repl-prompt  procedure?   standard-prompt)
  99. (define-simple-switch repl-read    procedure?   read)
  100. (define-simple-switch repl-eval    procedure?   eval)
  101. (define-simple-switch repl-print   procedure?   print)
  102. (define-simple-switch repl-input   input-port?  (standard-input))
  103. (define-simple-switch repl-output  output-port? (standard-output))
  104. (define-simple-switch repl-env     environment? t-implementation-env)
  105.  
  106. (define (initialize-repl env)
  107.   (set (repl-results)    (list (undefined-value "##")))
  108.   (set (repl-prompt)     standard-prompt)
  109.   (set (repl-read)       read)
  110.   (set (repl-eval)       eval)
  111.   (set (repl-print)      print)
  112.   (set (repl-input)      (standard-input))
  113.   (set (repl-output)     (standard-output))
  114.   (set (repl-env)        env))
  115.  
  116. ;;; random stuff.
  117.  
  118. (define (standard-prompt level)         ; arg is # of repls on stack.
  119.   (case level
  120.     ((0) "> ")
  121.     ((1) ">> ")
  122.     ((2) ">>> ")
  123.     ((3) ">>>> ")
  124.     (else
  125.      (string-append (map-string! (always #\>)
  126.                                  (make-string (fx+ level 1)))
  127.                     " "))))
  128.  
  129. (define (alternate-prompt level)
  130.   (case level
  131.     ((0) "> ")
  132.     ((1) "1: ")
  133.     ((2) "2: ")
  134.     ((3) "3: ")
  135.     (else (format nil "~s: " level))))
  136.  
  137. ;;; some commands.
  138. ;++ These belong elsewhere.  There should be a file command that implements
  139. ;++ command loops.
  140.  
  141. (define-integrable (current-frame)
  142.   (escape-procedure-frame **ret**))
  143.  
  144. (define (backtrace)
  145.   (*backtrace (current-frame)))
  146.  
  147. (define (crawl . rest)
  148.   (apply *crawl (repl-env) rest))
  149.  
  150. (define (debug)
  151.   (*crawl (repl-env) (current-frame)))
  152.  
  153. (define-syntax (pp form)
  154.   (cond ((symbol? form)
  155.          `(*pp-symbol ',form (repl-env)))
  156.         (else
  157.          `(*pp ,form))))
  158.